home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
bbs
/
jdrexa10.zip
/
INST4OF4.DAT
/
BBS
/
COMMIE03.ZIP
/
COMMIE.BAS
next >
Wrap
BASIC Source File
|
1994-12-16
|
37KB
|
1,260 lines
'
' Commie r.03
' John David Rohner, Milwaukee, WI
' December 1994
'
' Copyright (c) 1994, John Rohner. All rights reserved.
'
'Release History
'
' .01 initial release
' .02 GIP BMP graphics support
' .03 save and restore the screen when shelling
' dropped Avatar support
' much faster modem-to-screen throughput so no fossil buffers needed
' dropped CGA icon-fixing support
' faster icon and BMP viewing
' 286 or better now required
' should work with any fossil driver.
'
'
DEFINT A-Z
'
' Some constants and data types (from JDR_BBS).
'
CONST UpSC = 18432
CONST DownSC = 20480
CONST LeftSC = 19200
CONST RightSC = 19712
TYPE FileInfo 'Len = 29
FName AS STRING * 12 'File name.
FSize AS LONG 'File Size in bytes.
FDate AS STRING * 9 'File date (sometimes).
END TYPE
'
' General subroutine library (from JDR_BBS).
'
DECLARE SUB Ansi (Inpt$)
DECLARE FUNCTION AscMid% (Inpt$, BYVAL Start%)
DECLARE FUNCTION AscNull% (Inpt$)
DECLARE FUNCTION AscRight% (Inpt$)
DECLARE SUB BiosAnsi (st$)
DECLARE FUNCTION BitsRol% (BYVAL Inpt%, BYVAL ShiftLeft%)
DECLARE FUNCTION BitsRor% (BYVAL Inpt%, BYVAL ShiftRight%)
DECLARE FUNCTION BitsShl% (BYVAL Inpt%, BYVAL ShiftLeft%)
DECLARE FUNCTION BitsShr% (BYVAL Inpt%, BYVAL ShiftRight%)
DECLARE FUNCTION BitTest% (BYVAL Inpt%, BYVAL BitNum%)
DECLARE FUNCTION BlockIn% (BYVAL CommPort%, Send$)
DECLARE SUB BlockOut (BYVAL CommPort%, Send$)
DECLARE SUB ColorText (BYVAL Horiz%, BYVAL Vert%, BYVAL attr%,BYVAL char%)
DECLARE SUB CursorOff ()
DECLARE SUB CursorOn ()
DECLARE SUB DAMCSHLF (BYVAL Horiz%, BYVAL Vert%, Colors$, BYVAL i3%, BYVAL i4%)
DECLARE SUB Delay ()
DECLARE SUB DirCreate (st$)
DECLARE SUB FileClose (BYVAL Handle%)
DECLARE SUB FileGetSLoc (BYVAL Handle%, BYVAL Location&, Inpt$)
DECLARE SUB FileGetTD (BYVAL Handle%,i1%,i2%)
DECLARE FUNCTION FileLof& (BYVAL Handle%, BYVAL Divisor%)
DECLARE FUNCTION FileOpen% (FileName$,BYVAL attr%)
DECLARE SUB FilePutSEnd (BYVAL Handle%, Inpt$)
DECLARE SUB FileSetTD (BYVAL Handle%,BYVAL i1%,BYVAL i2%)
DECLARE FUNCTION FindF% (File$, Typ AS FileInfo)
DECLARE FUNCTION FindF2% (File$, Typ AS FileInfo)
DECLARE FUNCTION FosIntAX% (BYVAL Port%, BYVAL AX%)
DECLARE FUNCTION FosGetByte% (BYVAL Port%)
DECLARE SUB GLine (BYVAL CurrentH%, BYVAL CurrentV%, BYVAL TillH%, BYVAL TillV%, BYVAL Colr%, BYVAL GDither%)
DECLARE SUB GPixel (BYVAL Horiz%, BYVAL Vert%, BYVAL Colr%)
DECLARE SUB GSetMode (BYVAL GMode%, BYVAL VGA1%, BYVAL VGA2%)
DECLARE FUNCTION HexToInt% (p$)
DECLARE FUNCTION IntMid% (Inpt$, BYVAL Start%)
DECLARE FUNCTION KBIn% ()
DECLARE SUB KillFile (File$)
DECLARE FUNCTION LongMid& (Inpt$, BYVAL Start%)
DECLARE SUB RestScr (p$)
DECLARE SUB SaveScr (p$)
DECLARE FUNCTION StrCrc16% (st$)
DECLARE FUNCTION StrSrch1% (Inpt$, BYVAL Find%)
DECLARE FUNCTION StrSrch2% (BYVAL Start%, Inpt$, BYVAL Find%)
DECLARE SUB zShell (DoWhat$)
'
' Program specific subroutine library.
'
DECLARE SUB Ansi2 (p$)
DECLARE FUNCTION ConfirmFile% (p$)
DECLARE SUB DerCommie ()
DECLARE SUB DoGIPForComm ()
DECLARE SUB FileCloseR (p)
DECLARE SUB FileCloseW (p)
DECLARE FUNCTION FileGetLine$ (p,p&)
DECLARE FUNCTION FileOpenR% (p$)
DECLARE FUNCTION FileOpenW% (p$)
DECLARE FUNCTION FosGetB2000% ()
DECLARE FUNCTION FosGetByte2% ()
DECLARE SUB GBox (p,p0,p1,p2,p3,p4)
DECLARE SUB GBoxFilled (p,p0,p1,p2,p3,p4)
DECLARE SUB GIPFileXfer ()
DECLARE SUB GIPParse1 (p$,p0$,p)
DECLARE SUB GIPParse2 (p$,p0,p1,p2)
DECLARE SUB HangUp ()
DECLARE FUNCTION LineEditTT$ (p)
DECLARE FUNCTION NoCarrier% ()
DECLARE SUB PurgeComIO (p)
DECLARE SUB ShowIcon2 (FileName$)
DECLARE SUB ShowBMP (FileName$)
DECLARE FUNCTION Val4& (p$) 'to handle negatives.
DECLARE SUB ZeInit ()
'
' Global variables.
'
COMMON SHARED _
TT$, C1310$, Null$, Chars$(), o$(), FFile AS FileInfo, CommPort, DirectV, _
GInUse, GHoriz, GVert, GColor, GPattern, GPatShift, GObjects$(), Buff$, _
VGA1, VGA2
'
' Actual program start.
'
C1310$ = CHR$(13) + CHR$(10)
CALL Ansi("Commie GIP-able communications release .03" + C1310$)
CALL Ansi("Copyright (C) John David Rohner 1994. All rights reserved." + C1310$)
CALL ZeInit
CALL DerCommie
END
SUB DerCommie
GInUse = 0
GHoriz = 1
GVert = 1
GColor = 1
GPattern = 0
GPatShift = 0
KK$ = SPACE$(512)
1 SELECT CASE LEN(Buff$)
CASE 0
K = KBIn
SELECT CASE K
CASE IS < 1
K = BlockIn(CommPort,KK$)
SELECT CASE K
CASE IS > 0
K$ = LEFT$(KK$,K)
K = StrSrch1(K$,19)
IF K > 0 THEN Buff$ = MID$(K$,K + 1) : _
K$ = LEFT$(K$,K - 1)
K0 = StrSrch1(K$,12)
WHILE K0 > 0
K$ = LEFT$(K$,K0 - 1) + "" + MID$(K$,K0 + 1)
K0 = StrSrch1(K$,12)
WEND
CALL Ansi2(K$)
IF K > 0 THEN CALL DoGIPForComm
END SELECT
CASE 1 TO 255 : CALL BlockOut(CommPort,Chars$(K))
CASE UpSC : CALL BlockOut(CommPort,"A")
CASE DownSC : CALL BlockOut(CommPort,"B")
CASE LeftSC : CALL BlockOut(CommPort,"D")
CASE RightSC : CALL BlockOut(CommPort,"C")
CASE 15104 : CALL BlockOut(CommPort,o$(3,1)) '<F1>
CASE 15360 : CALL BlockOut(CommPort,o$(3,2)) '<F2>
CASE 15616 : CALL BlockOut(CommPort,o$(3,3)) '<F3>
CASE 15872 : CALL BlockOut(CommPort,o$(3,4)) '<F4>
CASE 16128 : CALL BlockOut(CommPort,o$(3,5)) '<F5>
CASE 16384 : CALL BlockOut(CommPort,o$(3,6)) '<F6>
CASE 16640 : CALL BlockOut(CommPort,o$(3,7)) '<F7>
CASE 16896 : CALL BlockOut(CommPort,o$(3,8)) '<F8>
CASE 17152 : CALL BlockOut(CommPort,o$(3,9)) '<F9>
CASE 17408 : CALL BlockOut(CommPort,o$(3,10)) '<F10>
CASE 8960 : CALL HangUp '<alt>h
CASE 11520 : CALL HangUp '<alt>x
SYSTEM
CASE 7936
'
' <alt>s shell to DOS.
'
CALL CommieShell("")
CASE 11776 ' <alt>c reset the screen mode.
CALL GSetMode(0,0,0)
GInUse = 0
TT$ = "
COMMIE r.03
--
simple terminal program with GIP VGA graphics abilty" + C1310$ + C1310$
TT$ = TT$ + "
Commands:
<pgup>
to send file(s)
<alt>s
to shell to DOS" + C1310$
TT$ = TT$ + "
<pgdn>
to receive file(s)
<alt>h
to hang up" + C1310$
TT$ = TT$ + "
<alt>c
to reset the screen
<alt>x
to exit" + C1310$ + C1310$
K0 = 1
WHILE AscNull(o$(1,K0)) <> 0
TT$ = TT$ + "│
" + o$(1,K0) + C1310$
K0 = K0 + 1
WEND
TT$ = TT$ + C1310$ + "
"
CALL Ansi2(TT$)
CALL CursorOn
CASE 18688
'
' <pgup> upload file(s).
'
IF GInUse <> 0 THEN CALL GSetMode(0,0,0) : _
GInUse = 0
CALL Ansi2("
BBB")
K = 0
K& = 0
K$ = Null$
DO
s$ = SPACE$(4002)
CALL SaveScr(s$)
TT$ = "
Sending:
" + _
STR$(K) + " files," + STR$(K&) + _
" bytes.
Filename to send:
"
SELECT CASE ConfirmFile(K0$)
CASE -1
K$ = K$ + K0$ + C1310$
K0 = FindF(K0$,FFile)
IF K0 <> 0 THEN DO : _
K = K + 1 : _
K& = K& + FFile.FSize : _
LOOP UNTIL FindF(Null$,FFile) = 0
END SELECT
LOOP UNTIL LEN(K0$) = 0
SELECT CASE LEN(K$)
CASE IS > 0
K0$ = LEFT$(o$(2,3),3) + "COMMIE." + _
LTRIM$(STR$(CommPort))
K = FileOpenW(K0$)
CALL FilePutSEnd(K,K$)
CALL FileCloseW(K)
IF NOT BitTest(FosIntAX(CommPort,&H300),15) _
THEN CALL Delay
K = FosIntAX(CommPort,&H0500) 'fossil off
IF GInUse <> 0 THEN CALL GSetMode(0,0,0) : _
GInUse = 0
LOCATE 25,1
CALL zShell(o$(2,3) + STR$(CommPort) + " sz -mr @" + K0$)
CALL KillFile(K0$)
K = FosIntAX(CommPort,&H1C00) 'Fossil on.
END SELECT
CALL RestScr(s$)
CALL Ansi2("")
CASE 20736
'
' <pgdn> download file(s).
'
CALL CommieShell(o$(2,3) + STR$(CommPort) + " rz -mr")
END SELECT
CASE ELSE
K$ = Buff$
K = StrSrch1(K$,19)
IF K = 0 THEN Buff$ = Null$ _
ELSE Buff$ = MID$(K$,K + 1) : _
K$ = LEFT$(K$,K - 1)
K0 = StrSrch1(K$,12)
WHILE K0 > 0
K$ = LEFT$(K$,K0 - 1) + "" + MID$(K$,K0 + 1)
K0 = StrSrch1(K$,12)
WEND
CALL Ansi2(K$)
IF K > 0 THEN CALL DoGIPForComm
END SELECT
GOTO 1
END SUB
SUB CommieShell (p$)
IF NOT BitTest(FosIntAX(CommPort,&H300),15) THEN CALL Delay
K = FosIntAX(CommPort,&H0500) 'fossil off
IF GInUse <> 0 THEN CALL GSetMode(0,0,0) : _
GInUse = 0
s$ = SPACE$(4002)
CALL SaveScr(s$)
LOCATE 25,1
CALL zShell(p$)
CALL RestScr(s$)
K = FosIntAX(CommPort,&H1C00) 'Fossil on.
CALL Ansi2("")
END SUB
'
' These next two GIP routines are pretty much exactly what's in the BBS's
' terminal program (COMMPROG.BAS).
'
SUB DoGIPForComm
'
' Get the key letter.
'
K = FosGetByte2
SELECT CASE K
CASE 76, 66, 70, 71, 77 : K0 = 3 'L, B, F, G, M
CASE 79, 80 : K0 = 2 'O, P
CASE 83, 67, 111, 79 : K0 = 0 'S, C, o
K1 = FosGetByte2
CASE ELSE : K0 = 0
END SELECT
'
' Get any integer parameters.
'
FOR K5 = 1 TO K0
K3 = FosGetByte2
K4 = FosGetByte2
K3 = K3 OR BitsShl(K4,8) 'Want an integer.
IF K5 = 1 THEN K1 = K3
IF K5 = 2 THEN K2 = K3
NEXT
'
' Process the key letter.
'
K4 = GHoriz
K5 = GVert
SELECT CASE K0
CASE 3
SELECT CASE GInUse
CASE 1, 3
IF K1 > 320 THEN K = 0
IF K2 > 200 THEN K = 0
CASE 2, 4
IF K1 > 640 THEN K = 0
IF K2 > 480 THEN K = 0
CASE 5
IF K1 > 800 THEN K = 0
IF K2 > 600 THEN K = 0
END SELECT
END SELECT
SELECT CASE K
CASE 71
'
' Gh,v,d; go to to point x,y,z.
'
GHoriz = K1
GVert = K2
CASE 76
'
' Lh,v,d; draw a line to offset h,v,d.
'
GHoriz = GHoriz + K1
GVert = GVert + K2
IF GInUse > 0 THEN CALL GLine(K4,K5,GHoriz,GVert,GColor,GPattern)
CASE 66
'
' Bh,v,d; draw a rectangle to offset corner h,v,d.
'
IF GInUse > 0 _
THEN CALL GBox(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
CASE 70
'
' Fh,v,d; draw a filled/solid rectangle to offset corner h,v,d.
'
IF GInUse > 0 _
THEN CALL GBoxFilled(GHoriz,GVert,GHoriz + K1,GVert + K2,GColor,GPattern)
CASE 83
'
' Sn; switch to screen mode n.
'
GHoriz = 0
GVert = 0
GColor = 15
GPattern = -1
GPatShift = 0
GInUse = K1
IF NOT DirectV THEN K1 = - K1
CALL GSetMode(K1,VGA1,VGA2)
CALL CursorOff
IF K1 = 0 THEN CALL CursorOn
CASE 67
'
' Cn; switch to color n.
'
GColor = K1
CASE 77
'
' Mh,v,d; go to to offset point h,v,d.
'
GHoriz = GHoriz + K1
GVert = GVert + K2
CASE 80
'
' Pn; switch to pattern n.
'
GPattern = K1
IF GPattern = 0 THEN GPattern = -1
GPatShift = K2
CASE 102 : CALL GIPFileXfer
CASE 111
'
' o###; to use an object. There must be no f cmds in it!
'
Buff$ = GObjects$(K1) + Buff$
CASE 79
'
' O###;~Define~ to define an object.
'
SELECT CASE K1
CASE 1 TO 255
K$ = Null$
FOR K0 = 1 TO K2
K$ = K$ + Chars$(FosGetByte2)
IF NoCarrier OR LEN(K$) = 2049 THEN EXIT FOR
NEXT
K& = - LEN(GObjects$(K1))
FOR K0 = 1 TO 255
K& = K& + LEN(GObjects$(K1))
NEXT
K0$ = Null$
K0 = 1
DO
K5 = AscMid(K$,K0)
SELECT CASE K5
CASE 19
K2 = AscMid(K$,K0 + 1)
CALL GIPParse1(K$,K1$,K0)
K2$ = Null$
IF LEN(K1$) = 0 THEN K2 = 0
SELECT CASE K2
CASE 83, 67, 111
K2$ = Chars$(Val4&(K1$))
CASE 66, 70, 71, 76, 77
CALL GipParse2(K1$,K3,K4,0)
K2$ = MKI$(K3) + MKI$(K4) + MKI$(0)
CASE 80
CALL GipParse2(K1$,K3,0,K4)
K2$ = MKI$(K3) + MKI$(K4)
END SELECT
IF LEN(K2$) > 0 _
THEN K0$ = K0$ + Chars$(19) + Chars$(K2) + K2$
CASE ELSE : K0$ = K0$ + Chars$(K5)
K0 = K0 + 1
END SELECT
LOOP UNTIL K0 > LEN(K$)
IF K& + LEN(K0$) < 8193 THEN GObjects$(K1) = K0$
END SELECT
END SELECT
END SUB
SUB GIPFileXfer
'
' fpathname; send a file.
'
' Header info = 8 GIP ID (directory)(padded with spaces)
' 12 file name (eg. "HELLO.ICO ")
' 4 file's size
' 2 file's time
' 2 file's date
' then send INT CRC of the above.
' then we send byte of either: ACK, ENQ, <esc>
'
K = 0
DO
IF K = 5 OR KBIn = 27 OR NoCarrier _
THEN CALL BlockOut(CommPort,Chars$(27)) : _
EXIT SUB
IF K > 0 THEN CALL BlockOut(CommPort,Chars$(5)) 'ENQ
K$ = Null$
FOR K0 = 1 TO 28
K$ = K$ + Chars$(FosGetByte2)
NEXT
K3 = FosGetByte2
K4 = FosGetByte2
K3 = K3 OR BitsShl(K4,8) 'Want an integer.
K = K + 1
LOOP UNTIL StrCrc16(K$) = K3
CALL BlockOut(CommPort,Chars$(6)) 'ACK
K& = LongMid&(K$,21)
K1 = IntMid(K$,25)
K2 = IntMid(K$,27)
K0$ = "BBSSTUFF\" + RTRIM$(LEFT$(K$,8)) + "\" + RTRIM$(MID$(K$,9,12))
K = FindF(K0$,FFile)
SELECT CASE K
CASE IS <> 0
K = FileOpenR(K0$)
CALL FileGetTD(K,K3,K4)
CALL FileCloseR(K)
IF FFile.FSize <> K& OR K1 <> K3 OR K2 <> K4 THEN K = 0
END SELECT
SELECT CASE K
CASE 0 'Re-send file.
CALL BlockOut(CommPort,Chars$(5)) 'Send an ENQ.
CALL DirCreate(K0$)
CALL KillFile(K0$)
K0& = 0
K3 = 0
IF K& > 1024 THEN K1$ = SPACE$(1024)
K = FileOpenW(K0$)
DO
IF K0& + 1024 > K& THEN K1$ = SPACE$(K& - K0&) : _
K3 = 0
K4 = LEN(K1$)
'kx$ = time$
DO
K0 = FosGetByte2
'''check for stop/abort keys. (pull from dispfile).
IF K0 >= 0 THEN K3 = K3 + 1 : _
MID$(K1$,K3,1) = Chars$(K0)
' CALL StrOverStr1(K1$,K3,K0)
LOOP UNTIL K3 = K4 OR NoCarrier 'OR ElapsedTime(kx$,0) = 1
''line up the diskread's and diskwrites--but don't send the ACK until after
''write to disk (so on the sending end, read the next block after immediately
''send the previous, then wait for ACK).
IF K3 = K4 THEN CALL FilePutSEnd(K,K1$) : _
CALL BlockOut(CommPort,Chars$(6)) : _
K3 = 0 : _
K0& = K0& + K4
LOOP UNTIL K0& = K& OR NoCarrier 'OR ElapsedTime(kx$,0) = 1
CALL FileSetTD(K,K1,K2)
CALL FileCloseW(K)
CASE ELSE 'File exists.
CALL BlockOut(CommPort,Chars$(6))
END SELECT
SELECT CASE FindF2(K0$,FFile)
CASE -1
SELECT CASE RIGHT$(K0$,4)
CASE ".ICO" : IF GInUse > 0 THEN CALL ShowIcon2(K0$)
CASE ".BMP" : IF GInUse > 0 THEN CALL ShowBMP(K0$)
CASE ELSE
CALL GSetMode(0,0,0)
GInUse = 0
K = FileOpenR(K0$)
K& = 0
DO : CALL Ansi2(FileGetLine$(K,K&))
LOOP UNTIL NoCarrier OR K& = -1
CALL FileCloseR(K)
END SELECT
END SELECT
END SUB
'
' Next few routines pulled from GIPSTUFF.BAS
'
'* * * * * *
' This routine will display an icon.
'
' p$ pathname of file to use.
'
' Date last checked for perfection: Oct 22 1993
'
SUB ShowIcon2 (p$)
K$ = SPACE$(16)
K = FileOpenR(p$)
CALL FileGetSLoc(K,6,K$)
K0 = ASC(K$)
K1 = AscMid(K$,2)
K2 = AscMid(K$,3)
K3 = LongMid&(K$,9)
K& = LongMid&(K$,13)
K$ = SPACE$((K1 \ 2) * K0)
CALL FileGetSLoc(K,K& + 104,K$)
CALL FileCloseR(K)
CALL DAMCSHLF(GHoriz,GVert + K0,K$,K1 \ 2,4)
END SUB
'
'* * * *
'quick and dirty BMP viewer--trouble with the colors right now.
'also need to modify it so it draws at the current ghoriz/gvert?
SUB ShowBMP (p$)
K = FileOpenR(p$)
zz$ = space$(27)
call filegetsloc(k,2&,zz$)
k1& = longmid(zz$,1) 'end of image
k& = longmid(zz$,9) 'start of image
kx1 = intmid(zz$,17) 'horizontal width
kx2 = intmid(zz$,21) 'vertical height
kz = ascmid(zz$,27) 'number of pixels per color
aa = kx2
if kz = 8 then xx = kx1 _
else xx = kx1 \ 2
xy = (16384 \ xx) * xx
x$ = space$(xy)
do
if (k1& - k&) < xy then x$ = left$(x$,k1& - k&)
CALL FileGetSLoc(K,k&,x$)
call DAMCSHLF(GHoriz,aa,x$,xx,kz)
k& = k& + xy
aa = aa - (xy \ xx)
loop until k& >= k1&
CALL FileCloseR(K)
END SUB
'* * * * * *
' This routine will display an empty rectangle.
'
' Date last checked for perfection: Oct 22 1993
'
SUB GBox (p,p0,p1,p2,p3,p4)
CALL GLine(p,p0,p1,p0,p3,p4)
CALL GLine(p1,p0,p1,p2,p3,p4)
CALL GLine(p1,p2,p,p2,p3,p4)
CALL GLine(p,p2,p,p0,p3,p4)
END SUB
'
'* * * *
'* * * * * *
' This routine will display a filled rectangle.
'
' Date last checked for perfection: Oct 22 1993
'
SUB GBoxFilled(p,p0,p1,p2,p3,p4)
SELECT CASE p0
CASE IS <= p2
FOR K = p0 TO p2
CALL GLine(p,K,p1,K,p3,p4)
IF GPatShift < 0 _
THEN p4 = BitsROL(p4,- GPatShift) _
ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
NEXT
CASE ELSE
FOR K = p0 TO p2 STEP -1
CALL GLine(p,K,p1,K,p3,p4)
IF GPatShift < 0 _
THEN p4 = BitsROL(p4,- GPatShift) _
ELSE IF GPatShift > 0 THEN p4 = BitsROR(p4,GPatShift)
NEXT
END SELECT
END SUB
'
'* * * *
'* * * * * *
' This routine will parse a section of string, pulling out the
' GIP string.
'
' p$ string to process.
'
' p0$ GIP string (excluding leading ASCII 19 and trailing semi-colon).
'
' p upon entry it points to the ASCII 19, upon return it points
' just after the semi-colon.
'
' Date last checked for perfection: Dec 7 1993
'
SUB GIPParse1 (p$,p0$,p)
K = StrSrch2(p,p$,59)
IF K > 0 AND LEN(p$) > 2 THEN p0$ = MID$(p$,p + 2,K - p - 2) : _
p = K + 1 _
ELSE p0$ = Null$ : _
p = p + 1
END SUB
'
'* * * *
'* * * * * *
' This routine will parses a 3-D GIP string for its three
' coordinates.
'
' p$ string to process.
'
' p0 returns with the h (first) coordinate.
'
' p1 returns with the v (second) coordinate.
'
' p2 returns with the d (third) coordinate.
'
' Date last checked for perfection: Dec 7 1993
'
SUB GIPParse2 (p$,p0,p1,p2)
p0 = StrSrch1(p$,44)
p1 = StrSrch2(p0,p$,44)
IF p0 > 0 THEN p0 = Val4&(LEFT$(p$,p0 - 1))
IF p1 > 0 THEN p1 = Val4&(LEFT$(p$,p1 - 1))
p2 = Val4&(p$)
END SUB
'
'* * * *
'
' Below this are just the support routines--the GIP stuff is above.
'
'* * * * * *
' This routine will read in our configuration data, and set up
' some useful variables.
'
' Date last checked for perfection: Oct 22 1993
'
SUB ZeInit
REDIM Chars$(255)
FOR K = 0 TO 255
Chars$(K) = CHR$(K)
NEXT
C1310$ = Chars$(13) + Chars$(10)
Null$ = ""
DirectV = 0
CommPort = 0
'
' Load config file into o$().
'
REDIM o$(3,100)
K = FileOpenR("COMMIE.CFG")
K& = 0
K0 = 0
K1 = 0
o$(1,1) = Chars$(0)
DO
K$ = FileGetLine$(K,K&)
SELECT CASE LEFT$(K$,5)
CASE "REMIN" : K1 = 1
K0 = -1
CASE "SETTI" : K1 = 2
o$(1,K0) = Chars$(0)
K0 = -1
CASE "MACRO" : K1 = 3
K0 = -1
END SELECT
K0 = K0 + 1
SELECT CASE K1
CASE 2
IF K0 = 1 THEN K2 = StrSrch1(K$,32) : _
IF K2 > 0 THEN K$ = LEFT$(K$,K2)
IF K0 <> 3 AND K0 <> 1 THEN K$ = LEFT$(K$,7)
K$ = RTRIM$(K$)
IF K0 = 5 THEN VGA1 = HexToInt(K$)
IF K0 = 6 THEN VGA2 = HexToInt(K$)
CASE 3
K$ = MID$(K$,4)
K2 = StrSrch1(K$,124)
WHILE K2 > 0
K$ = LEFT$(K$,K2 - 1) + C1310$ + MID$(K$,K2 + 1)
K2 = StrSrch1(K$,124)
WEND
END SELECT
IF K1 > 0 THEN o$(K1,K0) = K$
LOOP UNTIL K& = -1
CALL FileCloseR(K)
'
' Display opening screen and get comm port to use.
'
REDIM GObjects$(255)
TT$ = "
COMMIE r.03
--
simple terminal program with GIP VGA graphics abilty" + C1310$ + C1310$
TT$ = TT$ + "
Commands:
<pgup>
to send file(s)
<alt>s
to shell to DOS" + C1310$
TT$ = TT$ + "
<pgdn>
to receive file(s)
<alt>h
to hang up" + C1310$
TT$ = TT$ + "
<alt>c
to reset the screen
<alt>x
to exit" + C1310$ + C1310$
K0 = 1
WHILE AscNull(o$(1,K0)) <> 0
TT$ = TT$ + "│
" + o$(1,K0) + C1310$
K0 = K0 + 1
WEND
CALL Ansi2(TT$)
TT$ = C1310$ + "
Port modem is connected to [1] :
"
CALL CursorOn
K$ = LineEditTT$(2)
IF ASCNull(K$) = 27 THEN SYSTEM
IF LEN(K$) > 0 THEN CommPort = ASC(K$) - 48 _
ELSE CommPort = 1 : _
CALL Ansi2("1")
'
'Make sure a fossil is installed, exit with message if not.
'
IF FosIntAX(CommPort,&H1C00) <> &H1954 _
THEN CALL Ansi2(C1310$ + C1310$ + "
Fossil driver not found!" + C1310$) : _
CALL Delay : _
SYSTEM
'
' Re-init fossil.
'
SELECT CASE o$(2,2)
CASE "38400" : K = 35 '001 00011
CASE "19200" : K = 3 '000 00011
CASE "9600" : K = 227 '111 00011
CASE "1200" : K = 131 '100 00011
CASE ELSE : K = 163 '101 00011
END SELECT
K = FosIntAX(CommPort,K)
CALL Ansi2(C1310$ + C1310$ + "
Type
ATDT<phone#>
to contact a BBS.
" + C1310$ + C1310$)
CALL BlockOut(CommPort,o$(2,1) + C1310$)
IF o$(2,4) = "DIRECT ON" THEN DirectV = -1
Buff$ = Null$
END SUB
'
'* * * *
'* * * * * *
' This routine will purge the fossil and modem I/O buffers.
'
' p Comm Port
'
' It relies on the fossil to purge the modem buffers.
'
' Date last checked for perfection: Oct 21 1993
'
SUB PurgeComIO (p)
k = FosIntAX(p,&HA00) 'Purge the fossil's input buffer.
k = FosIntAX(p,&H900) 'Purge the fossil's output buffer.
DO : k = FosGetB2000 'Purge the modem's input buffer.
LOOP UNTIL k < 1 'Just to be sure.
END SUB
'
'* * * *
FUNCTION FosGetB2000%
K = FosIntAX(CommPort,&H0C00) '-1 or 0 to 255 (peek)
IF K <> -1 THEN K = FosGetByte(CommPort)
FosGetB2000% = K
END FUNCTION
'* * * * * *
' This routine will ANSI display text.
'
' p$ text to display
'
' Date last checked for perfection: Oct 21 1993
'
SUB Ansi2 (p$)
IF DirectV AND GInUse = 0 THEN CALL BiosAnsi(p$) : _
EXIT SUB
IF GInUse = 0 THEN CALL Ansi(p$) : _
EXIT SUB
'
' Graphic text drawing.
'
K$ = p$
WHILE LEN(K$) > 0
K = ASC(K$)
IF K = 10 THEN K = -1
IF K = 13 THEN GHoriz = 0 : _
GVert = GVert + 8 : _
K = -1
IF K >= 0 THEN CALL ColorText(GHoriz,GVert,GColor,K) : _
GHoriz = GHoriz + 8
K$ = MID$(K$,2)
WEND
END SUB
'
'* * * *
'* * * * * *
' This routine will signal Yea or Nay as to the status of the
' carrier.
'
' returns -1 if no carrier detected
' 0 if carrier present
'
' Remember, this is 'NO Carrier'--true when no carrier is
' detected.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION NoCarrier%
IF BitTest(FosIntAX(CommPort,&H300),8) THEN NoCarrier% = 0 _
ELSE NoCarrier% = -1
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will hang up the phone.
'
' Date last checked for perfection: Oct 21 1993
'
SUB HangUp
k = FosIntAX(CommPort,&H600) 'Lower DTR.
CALL Delay
k = FosIntAX(CommPort,&H601) 'Raise DTR.
CALL Delay
IF NoCarrier THEN CALL PurgeComIO(CommPort) : _
EXIT SUB
DO
k = FosIntAX(CommPort,&H600) 'Lower DTR.
CALL Delay
k = FosIntAX(CommPort,&H601) 'Raise DTR.
CALL Delay
LOOP UNTIL NoCarrier
CALL PurgeComIO(CommPort)
END SUB
'
'* * * *
'in reverse to minimize -'ve rollover effects
FUNCTION HexToInt% (p$)
K$ = UCASE$(p$)
IF AscRight(K$) <> 72 THEN HexToInt% = Val4&(K$) : _
EXIT FUNCTION
K$ = RIGHT$("0000" + LEFT$(K$,LEN(K$) - 1),4)
FOR K = 4 TO 1 STEP -1
K0 = AscMid(K$,K)
K0 = StrSrch1("0123456789ABCDEF",K0) - 1
SELECT CASE K
CASE 1 : K1 = K1 + K0 * 4096
CASE 2 : K1 = K1 + K0 * 256
CASE 3 : K1 = K1 + K0 * 16
CASE 4 : K1 = K0
END SELECT
NEXT
HexToInt% = K1
END FUNCTION
'* * * * * *
' This routine retrieves the next line of 'sequential' text
' from an already opened file.
'
' p file handle to read from.
'
' p& location to start reading from. p& is increased by the
' size of the returned string + 2. -1 is returned at EOF.
'
' If the retrieved 128 byte buffer has no CR/LF, then returns
' with all 128 bytes read.
'
' A line with only a CR/LF on it is returned as a null.
'
' The CR/LF is not included in the returned text.
'
' At EOF, returned text may or may not contain text, but p&
' will be -1.
'
' The last line read may or may not contain data (assume it
' does).
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION FileGetLine$ (p,p&)
k& = FileLof&(p,1) - 2
IF p& >= k& OR p& < 0 THEN FileGetLine$ = Null$ : _
p& = -1 : _
EXIT FUNCTION
k$ = SPACE$(128)
k = 1
DO
IF k = 0 THEN K$ = K$ + K$ 'we stop before it gets to 8192.
CALL FileGetSLoc(p,p&,k$)
k = StrSrch1(k$,13)
WHILE K > 0 AND AscMid(K$,k + 1) <> 10
K = StrSrch2(K,K$,13)
WEND
IF K = 0 AND p& + LEN(K$) > K& THEN K = StrSrch1(K$,0)
LOOP UNTIL k <> 0 OR LEN(K$) >= 4096 OR p& + LEN(K$) > K&
IF k > 0 THEN k$ = LEFT$(k$,k - 1) _
ELSE k = LEN(K$)
p& = p& + k + 1
IF p& >= k& THEN p& = -1
FileGetLine$ = k$
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will open a file in read-only, and read/write
' share mode.
'
' p$ pathname of the file to open.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION FileOpenR% (p$)
K = FileOpen(p$,128)
IF K = -1 THEN TT$ = C1310$ + C1310$ + _
"
File error, unable to open " + _
p$ + "" + C1310$ + C1310$ : _
CALL Ansi(TT$) : _
SYSTEM
FileOpenR% = K
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will close a file opened with FileOpenR.
'
' p handle of already-opened file.
'
' Date last checked for perfection: Oct 21 1993
'
SUB FileCloseR (p)
CALL FileClose(p)
END SUB
'
'* * * *
'* * * * * *
' This routine will get text input for a question answer.
'
' p maximum size of input allowed
'
' The CR/LF is removed.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION LineEditTT$ (p)
CALL Ansi2(TT$)
K0$ = SPACE$(p)
K1 = 0
DO
K3 = KBIn
SELECT CASE K3
CASE IS < 1
CASE IS > 255 : SYSTEM
CASE 8, 127
IF K1 > 0 THEN K1 = K1 - 1 : _
CALL Ansi2(Chars$(8) + " " + Chars$(8))
CASE 27 : K0$ = Chars$(27)
EXIT DO
CASE 13 : K0$ = LEFT$(K0$,K1)
EXIT DO
CASE ELSE
K1 = K1 + 1
MID$(K0$,K1,1) = Chars$(K3)
CALL Ansi2(Chars$(K3))
END SELECT
LOOP UNTIL K1 = p
LineEditTT$ = K0$
END FUNCTION
'
'* * * *
'* * * * * *
' This routine waits for the user to enter a pathname, and
' then confirms that it exists.
'
' p$ returns with the pathname if found
'
' returns with 0 if the file was not found, -1 if it was.
'
' A SendTT is done, so just set TT or TT$ and call this.
'
' A CR/LF is displayed no matter the result.
'
' If the file is not found, p$ is not set to zero, but
' instead contains the pathname not found. If [Enter]
' alone is hit, then NULL is returned in p$.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION ConfirmFile% (p$)
p$ = UCASE$(LTRIM$(RTRIM$(LineEditTT$(40))))
IF LEN(p$) = 0 OR ASCNull(p$) = 27 THEN ConfirmFile% = 0 : _
EXIT FUNCTION
IF FindF(p$,FFile) <> 0 THEN ConfirmFile% = -1 : _
EXIT FUNCTION
CALL Ansi2("
File not Found.")
CALL Delay
ConfirmFile% = 0
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will open a file for read/write and read-only
' share mode.
'
' p$ pathname of the file to open.
'
' Date last checked for perfection: Oct 21 1993
'
FUNCTION FileOpenW% (p$)
K = FileOpen(p$,130)
IF K = -1 THEN TT$ = C1310$ + C1310$ + _
"
File error, unable to open " + _
p$ + "" + C1310$ + C1310$ : _
CALL Ansi(TT$) : _
SYSTEM
FileOpenW% = K
END FUNCTION
'
'* * * *
'* * * * * *
' This routine will close a file opened with FileOpenW.
'
' p handle of already-opened file.
'
' Date last checked for perfection: Oct 21 1993
'
SUB FileCloseW (p)
CALL FileClose(p)
END SUB
'
'* * * *
'* * * * * *
' This routine will return a character from the port, or
' from the buffer.
'
' Date last checked for perfection: Nov 10 1993
'
FUNCTION FosGetByte2
IF LEN(Buff$) > 0 _
THEN K = ASC(Buff$) : _
Buff$ = MID$(Buff$,2) _
ELSE KK$ = SPACE$(2048) : _
K = BlockIn(CommPort,KK$) : _
IF K = 0 THEN K = FosGetByte(CommPort) _
ELSE Buff$ = MID$(KK$,2,K - 1) : _
K = ASC(KK$)
FosGetByte2 = K
END FUNCTION
'
'* * * *
FUNCTION Val4& (p$)
k& = 0
k0& = 1
K = LEN(RTRIM$(p$))
SELECT CASE K
CASE IS > 15
K3 = 0
FOR K0 = 0 TO 15
K1 = AscMid(p$,K - K0) - 48
IF K1 = 1 THEN CALL BitSet(K3,K0 + 1) _
ELSE IF K1 <> 0 THEN EXIT FOR
NEXT
IF K0 = 16 THEN K = -1 : _
K& = K3
END SELECT
K1 = 0
SELECT CASE K
CASE IS > 0
DO
K0 = AscMid(p$,K) - 48
K1 = K1 + 1
IF (K0 < 0) OR (K0 > 9) OR (K1 = 11) OR (K1 = 10 AND K0 > 1) _
THEN EXIT DO
k& = k& + k0& * K0
k0& = 10 * k0&
K = K - 1
LOOP UNTIL K = 0
IF K > 0 THEN IF AscMid(p$,K) = 45 THEN K& = - K&
END SELECT
Val4& = k&
END FUNCTION
'
' to compile: BC COMMIE.BAS /O/S/FS/G2;
' to link : LINK /EXEPACK /PACKCODE COMMIE,,,ASSEMBLY\JDRBBS,,
' requires : BC.EXE, LINK.EXE, BCL70EFR.LIB, BRT70EFR.LIB, and JDRBBS.LIB
' (Basic PDS 7.0+, and Juggernaut's assembly library)
'